home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / dskfn.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  21.2 KB  |  524 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8.  
  9. (in-package "MAXIMA")
  10. ;    ** (c) Copyright 1982 Massachusetts Institute of Technology **
  11.  
  12. (macsyma-module dskfn)
  13.  
  14. (declare-top (GENPREFIX DK)
  15.      (SPECIAL $FILENAME $DEVICE $DIREC $STORENUM $FILENUM $DSKALL
  16.           $FILESIZE FILELIST FILELIST1 OPERS $PACKAGEFILE
  17.           FASDUMPFL FASDEQLIST FASDNONEQLIST SAVENOHACK
  18.           DSKSAVEP AAAAA ERRSET LESSORDER GREATORDER INDLIST
  19.           $LABELS $ALIASES VARLIST MOPL $PROPS DEFAULTF
  20.           $INFOLISTS $FEATURES FEATUREL SAVEFILE $GRADEFS
  21.           $VALUES $FUNCTIONS $ARRAYS PRINLENGTH PRINLEVEL
  22.           $CONTEXTS CONTEXT $ACTIVECONTEXTS)
  23.      (FIXNUM N $FILESIZE $STORENUM $FILENUM)
  24.      (*LEXPR $FACTS))
  25.  
  26.  
  27. (SETQ FILELIST NIL FILELIST1 NIL $PACKAGEFILE NIL
  28.       INDLIST (PURCOPY '(EVFUN EVFLAG BINDTEST NONARRAY SP2 SP2SUBS OPERS 
  29.              SPECIAL AUTOLOAD ASSIGN MODE)))
  30.  
  31. (DEFMSPEC $UNSTORE (FORM) (I-$UNSTORE (CDR FORM)))
  32.  
  33. (DEFMFUN I-$UNSTORE (X)
  34.  (DO ((X X (CDR X)) (LIST (NCONS '(MLIST SIMP))) (PROP) (FL NIL NIL))
  35.      ((NULL X) LIST)
  36.      (SETQ X (INFOLSTCHK X))
  37.      (WHEN (AND (BOUNDP (CAR X)) (MFILEP (SETQ PROP (SYMBOL-VALUE (CAR X)))))
  38.        (SETQ FL T)
  39.        (SET (CAR X) (EVAL (DSKGET (CADR PROP) (CADDR PROP) 'VALUE NIL))))
  40.      (DO ((PROPS (CDR (OR (safe-GET (CAR X) 'MPROPS) '(NIL))) (CDDR PROPS))) ((NULL PROPS))
  41.      (COND ((MFILEP (CADR PROPS))
  42.         (SETQ FL T)
  43.         (COND ((MEMQ (CAR PROPS) '(HASHAR ARRAY))
  44.                (LET ((AAAAA (GENSYM)))
  45.              (SETQ PROP (DSKGET (CADADR PROPS)
  46.                         (CADDR (CADR PROPS))
  47.                         (CAR PROPS)
  48.                         T))
  49.              (MPUTPROP (CAR X)
  50.                    (IF (EQ PROP 'AAAAA) AAAAA (CAR X))
  51.                    (CAR PROPS))))
  52.               (T (SETQ PROP (DSKGET (CADADR PROPS) (CADDR (CADR PROPS))
  53.                         (CAR PROPS) NIL))
  54.              (MPUTPROP (CAR X) PROP (CAR PROPS)))))))
  55.      (AND FL (NCONC LIST (NCONS (CAR X))))))
  56.  
  57. (DEFUN INFOLSTCHK (X)    
  58.  ((LAMBDA (ITEML)
  59.    (IF (EQ ITEML T) X (APPEND (OR ITEML '(NIL)) (CDR X))))
  60.   (COND ((NOT (AND X (OR (MEMQ (CAR X) '($ALL $CONTEXTS))
  61.              (MEMQ (CAR X) (CDR $INFOLISTS)))))
  62.      T)
  63.     ((EQ (CAR X) '$ALL)
  64.      (INFOLSTCHK (APPEND (CDR $INFOLISTS)
  65.                  '($LINENUM $RATVARS $WEIGHTLEVELS *RATWEIGHTS
  66.                    TELLRATLIST $DONTFACTOR $FEATURES $CONTEXTS))))
  67.     ((EQ (CAR X) '$LABELS) (REVERSE (CDR $LABELS)))
  68.     ((MEMQ (CAR X) '($FUNCTIONS $MACROS $GRADEFS $DEPENDENCIES))
  69.      (MAPCAR #'CAAR (CDR (SYMBOL-VALUE (CAR X)))))
  70.     ((EQ (CAR X) '$CONTEXTS) (DELQ '$GLOBAL (REVERSE (CDR $CONTEXTS)) 1))
  71.     (T (CDR (SYMBOL-VALUE (CAR X)))))))
  72.  
  73.  
  74. (defun filelength (file)
  75.   (file-length file))
  76.  
  77.  
  78. (DEFMSPEC $SAVE (FORM) (DSKSETUP (CDR FORM) NIL NIL '$SAVE))
  79.  
  80.  
  81. (DEFMFUN I-$STORE (X) (DSKSETUP X T NIL '$STORE))
  82.  
  83. (DEFMSPEC $FASSAVE (FORM) (DSKSETUP (CDR FORM) NIL T '$FASSAVE))
  84.  
  85. (defvar *macsyma-extend-types-saved* nil)
  86.  
  87. #-(OR CL NIL)
  88. (DEFUN DSKSETUP (X STOREFL FASDUMPFL FN)
  89.   (LET (#-cl(*NOPOINT T) PRINLENGTH PRINLEVEL OFILE FILE
  90.     LIST FASDEQLIST FASDNONEQLIST MAXIMA-ERROR #+PDP10 LENGTH #+PDP10 OINT)
  91.     #-Franz
  92.     (SETQ FILE (COND (($LISTP (CAR X)) (PROG1 (FILESTRIP (CDAR X)) (SETQ X (CDR X))))
  93.              (T ;;Set OFILE to the last thing we wrote to.
  94.             #-CL (SETQ OFILE (DEFAULTF ()))
  95.             #+CL (SETQ OFILE (FILE-EXPAND-PATHNAME ""))
  96.             ;;Cons up a new filename if none specified in
  97.             ;;SAVE or STORE command.
  98.             #+Multics
  99.             (merror "First argument to ~:M must be a list.~
  100.                  ~%~:M([/"myfile/"],all); is acceptable."
  101.                 FN FN)
  102.             #-Multics
  103.             (FULLSTRIP (LIST $FILENAME
  104.                      (IF DSKSAVEP
  105.                          (SETQ $STORENUM (f1+ $STORENUM))
  106.                          (SETQ $FILENUM (f1+ $FILENUM)))
  107.                      $DEVICE $DIREC)))))
  108.     #+Franz (setq file (filestrip x) x (cdr x))
  109.     ;;Lisp Machine FILESTRIP returns a string.  Fix later.
  110.     #+LISPM (IF (STRINGP FILE) (SETQ FILE (UNEXPAND-PATHNAME FILE)))
  111.     (DOLIST (U X)
  112.       (COND ((ATOM U) (IF (NOT (SYMBOLP U)) (IMPROPER-ARG-ERR U FN)))
  113.         ((LISTARGP U))
  114.         ((OR (NOT (EQ (CAAR U) 'MEQUAL)) (NOT (SYMBOLP (CADR U))))
  115.          (IMPROPER-ARG-ERR U FN))))
  116.     #-Franz
  117.    (IF (AND STOREFL (EQ (CADR FILE) '>))
  118.        (MERROR "> as second filename has not been implemented for STORE."))
  119.    #+PDP10 (IF STOREFL (SETQ OINT (NOINTERRUPT 'TTY)))
  120.    (COND (DSKSAVEP (SETQ FILELIST (CONS FILE FILELIST)))
  121.      (OFILE (SETQ FILELIST1 (CONS FILE FILELIST1))))
  122.    ;;Create a stream to the file.  On ITS, use a hack to avoid repeated
  123.    ;;creation of file arrays.
  124.    #-Franz
  125.    (LET ((TEMP-FILE #-Multics`(,(CARFILE (CDDR FILE)) |!SAVE!| OUTPUT)
  126.             #+Multics "macsyma.saved.output"))
  127.      #+PDP10 (OPEN (CNAMEF SAVEFILE TEMP-FILE)
  128.            (IF FASDUMPFL '(OUT FIXNUM BLOCK) '(OUT ASCII)))
  129.      #+CL (SETQ SAVEFILE (OPEN TEMP-FILE :DIRECTION :OUTPUT))
  130.      #-(OR CL PDP10) (SETQ SAVEFILE (OPEN TEMP-FILE '(OUT ASCII))))
  131.    #+Franz (setq savefile (outfile file))
  132.    (LET ((*print-base* 10.))
  133.      #-cl(SETQ *NOPOINT NIL)
  134.      (WHEN (NULL FASDUMPFL)
  135.        (PRINC ";;; -*- Mode: LISP; package:maxima; syntax:common-lisp; -*- Saved by " SAVEFILE)
  136.        (PRINC (sys-user-id) SAVEFILE))
  137.      #-(or Franz CL Multics) (FASPRINT T `(SETQ SAVENO ,SAVENOHACK))
  138.      (SETQ LIST (NCONS (IF (SYMBOLP FILE) FILE (MFILE-OUT FILE)))
  139.        X (CONS '$ALIASES X)
  140.        *macsyma-extend-types-saved* nil)
  141.      (IF (NULL (ERRSET (DSKSTORE X STOREFL FILE LIST))) (SETQ MAXIMA-ERROR T))
  142.      (if (not (null *macsyma-extend-types-saved*))
  143.      (block nil
  144.        (if (null (errset
  145.               (dskstore (cons '&{ *macsyma-extend-types-saved*)
  146.                 storefl file list)))
  147.            (setq MAXIMA-ERROR t))
  148.        (setq *macsyma-extend-types-saved* nil)))
  149.      #-cl(SETQ *NOPOINT T))
  150.    (COND ((NULL (CDR LIST))
  151.       (DELETEF SAVEFILE)
  152.       (IF (NOT DSKSAVEP)
  153.           (MTELL "~M~%Nothing has been ~:Md.  ~:M attempt aborted."
  154.              (CAR LIST) FN FN))
  155.       (SETQ LIST '$ABORTED))
  156.      #-Franz
  157.      (FASDUMPFL (*FASDUMP SAVEFILE (NREVERSE FASDNONEQLIST) (NREVERSE FASDEQLIST) NIL)
  158.             (RENAMEF SAVEFILE FILE))
  159.      (T (TERPRI SAVEFILE) #-Franz (RENAMEF SAVEFILE FILE)))
  160.    #+PDP10 (IF STOREFL (NOINTERRUPT OINT))
  161.    #-(or Franz CL Multics) (DEFAULTF (IF DSKSAVEP OFILE FILE))
  162.    #+PDP10
  163.    (WHEN (NOT (ATOM LIST))
  164.      (RPLACA LIST (MTRUENAME SAVEFILE))
  165.      (SETQ LENGTH (FILELENGTH SAVEFILE))
  166.      (WHEN (> (CADR LENGTH) 30.)
  167.            (MTELL "~:M is ~A blocks big!" (CAR LIST) (CADR LENGTH))
  168.            (COND ((> (CADR LENGTH) 60.)
  169.               (MTELL "You probably want to zl-DELETE it."))
  170.              ((> (CADR LENGTH) 50.)
  171.               (MTELL "Do you really want such a large file?")))))
  172.    (IF MAXIMA-ERROR (LET ((ERRSET 'ERRBREAK1)) (MERROR "Error in ~:M attempt" FN)))
  173.    ;;The CLOSE happens inside of RENAMEF on ITS.
  174.    #-PDP10 (CLOSE SAVEFILE)
  175.    (IF (ATOM LIST) LIST
  176.            `((MLIST SIMP) ,(CAR LIST) #+PDP10 ,LENGTH . ,(CDR LIST))))) 
  177.  
  178. #+(OR CL NIL)
  179. (DEFUN DSKSETUP (X STOREFL FASDUMPFL FN)
  180.  (LET (#-cl(*NOPOINT T) PRINLENGTH PRINLEVEL OFILE FILE
  181.        *print-gensym*
  182.        LIST FASDEQLIST FASDNONEQLIST MAXIMA-ERROR #+PDP10 LENGTH #+PDP10 OINT)
  183.    #+CL
  184.    (SETQ SAVEFILE (OPEN (NSUBSTRING (STRING (CAR X)) 1) :DIRECTION :OUTPUT))
  185.    #+NIL
  186.    (setq savefile (open ($filename_merge (car x)) :out))
  187.    (SETQ FILE (LIST (CAR X)))
  188.    (WHEN (NULL FASDUMPFL)
  189.      (PRINC ";;; -*- Mode: LISP; package:maxima; syntax:common-lisp; -*- " SAVEFILE)
  190.      (terpri savefile)
  191.      (PRINC "(in-package \"MAXIMA\")" SAVEFILE)
  192.      )
  193.    (DOLIST (U X)
  194.        (COND ((ATOM U) (IF (NOT (SYMBOLP U)) (IMPROPER-ARG-ERR U FN)))
  195.          ((LISTARGP U))
  196.          ((OR (NOT (EQ (CAAR U) 'MEQUAL)) (NOT (SYMBOLP (CADR U))))
  197.           (IMPROPER-ARG-ERR U FN))))
  198.    (COND (DSKSAVEP (SETQ FILELIST (CONS FILE FILELIST)))
  199.      (OFILE (SETQ FILELIST1 (CONS FILE FILELIST1))))
  200.    (SETQ LIST (NCONS (CAR X)) X (CDR X) *macsyma-extend-types-saved* nil)
  201.    (IF (NULL (ERRSET (DSKSTORE X STOREFL FILE LIST))) (SETQ MAXIMA-ERROR T))
  202.    (if (not (null *macsyma-extend-types-saved*))
  203.        (block nil
  204.      (if (null (errset
  205.             (dskstore (cons '&{ *macsyma-extend-types-saved*)
  206.                   storefl file list)))
  207.          (setq MAXIMA-ERROR t))
  208.      (setq *macsyma-extend-types-saved* nil)))
  209.    (CLOSE SAVEFILE)
  210.    (namestring savefile)))
  211.  
  212. (DEFUN DSKSTORE (X STOREFL FILE LIST)
  213.   (DO ((X X (CDR X)) (VAL) (RENAME) (ITEM)
  214.        (ALRDYSTRD) (STFL STOREFL STOREFL) (NITEMFL NIL NIL))
  215.       ((NULL X))
  216.       (COND ((SETQ VAL (LISTARGP (CAR X)))
  217.          (SETQ X (NCONC (GETLABELS (CAR VAL) (CDR VAL) NIL) (CDR X))))
  218.         ((SETQ VAL (ASSQ (CAR X) '(($CLABELS . $INCHAR) ($DLABELS . $OUTCHAR)
  219.                        ($ELABELS . $LINECHAR))))
  220.          (SETQ X (NCONC (GETLABELS* (EVAL (CDR VAL)) NIL) (CDR X)))))
  221.       (IF (NOT (ATOM (CAR X)))
  222.       (SETQ RENAME (CADAR X) ITEM (GETOPR (CADDAR X)))
  223.       (SETQ X (INFOLSTCHK X) ITEM (SETQ RENAME (AND X (GETOPR (CAR X))))))
  224.       (COND ((NOT (SYMBOLP ITEM))
  225.          (SETQ NITEMFL ITEM)
  226.          (SETQ ITEM (LET ((NITEM (GENSYM))) (SET NITEM (MEVAL ITEM)) NITEM)))
  227.         ((EQ ITEM '$RATWEIGHTS) (SETQ ITEM '*RATWEIGHTS))
  228.         ((EQ ITEM '$TELLRATS) (SETQ ITEM 'TELLRATLIST)))
  229.       (COND
  230.        ((NULL X) (RETURN NIL))
  231.        ((NULL (CAR X)))
  232.        ((AND (SETQ VAL (ASSQ ITEM ALRDYSTRD)) (EQ RENAME (CDR VAL))))
  233.        ((NULL (SETQ ALRDYSTRD (CONS (CONS ITEM RENAME) ALRDYSTRD))))
  234.        ((AND (OR (NOT (BOUNDP ITEM))
  235.          (AND (EQ ITEM '$RATVARS) (NULL VARLIST))
  236.          (PROG2 (SETQ VAL (SYMBOL-VALUE ITEM))
  237.             (OR (AND (MEMQ ITEM '($WEIGHTLEVELS $DONTFACTOR))
  238.                  (NULL (CDR VAL)))
  239.                 (AND (MEMQ ITEM '(TELLRATLIST *RATWEIGHTS)) (NULL VAL))
  240.                 (AND (EQ ITEM '$FEATURES) (ALIKE (CDR VAL) FEATUREL))
  241.                 (AND (EQ ITEM '$DEFAULT_LET_RULE_PACKAGE)
  242.                  (EQ ITEM VAL))))
  243.          (AND (MFILEP VAL)
  244.               (OR DSKSAVEP (NOT (UNSTOREP ITEM)) (NULL (SETQ STFL T)))))
  245.          (OR (NULL (SETQ VAL (safe-GET ITEM 'MPROPS))) (EQUAL VAL '(NIL))
  246.          (IF (NOT DSKSAVEP) (NOT (UNSTOREP ITEM))))
  247.          (NOT (GETL ITEM '(OPERATORS REVERSEALIAS GRAD NOUN VERB EXPR OP DATA)))
  248.          (NOT (MEMQ ITEM (CDR $PROPS)))
  249.          (OR (NOT (MEMQ ITEM (CDR $CONTEXTS)))
  250.          (NOT (EQ ITEM '$INITIAL))
  251.              (LET ((CONTEXT '$INITIAL)) (NULL (CDR ($FACTS '$INITIAL)))))))
  252.        (T (WHEN (AND (BOUNDP ITEM) (NOT (MFILEP (SETQ VAL (SYMBOL-VALUE ITEM)))))
  253.         (IF (EQ ITEM '$CONTEXT) (SETQ X (LIST* NIL VAL (CDR X))))
  254.         (DSKATOM ITEM RENAME VAL)
  255.         (IF (NOT (OPTIONP RENAME)) (INFOSTORE ITEM FILE 'VALUE STFL RENAME)))
  256.       (WHEN (SETQ VAL (AND (MEMQ ITEM (CDR $ALIASES)) (GET ITEM 'REVERSEALIAS)))
  257.         (DSKDEFPROP RENAME VAL 'REVERSEALIAS)
  258.         (PRADD2LNC RENAME '$ALIASES)
  259.         (DSKDEFPROP (MAKEALIAS VAL) RENAME 'ALIAS)
  260.         (AND GREATORDER (NOT (ASSQ 'GREATORDER ALRDYSTRD))
  261.              (SETQ X (LIST* NIL 'GREATORDER (CDR X))))
  262.         (AND LESSORDER (NOT (ASSQ 'LESSORDER ALRDYSTRD))
  263.              (SETQ X (LIST* NIL 'LESSORDER (CDR X))))
  264.         (SETQ X (LIST* NIL (MAKEALIAS VAL) (CDR X))))
  265.       (COND ((SETQ VAL (GET ITEM 'NOUN))
  266.          (SETQ X (LIST* NIL VAL (CDR X)))
  267.          (DSKDEFPROP RENAME VAL 'NOUN))
  268.         ((SETQ VAL (GET ITEM 'VERB))
  269.          (SETQ X (LIST* NIL VAL (CDR X)))
  270.          (DSKDEFPROP RENAME VAL 'VERB)))
  271.       (WHEN (MGET ITEM '$RULE)
  272.         (IF (SETQ VAL (RULEOF ITEM))
  273.             (SETQ X (LIST* NIL VAL (CDR X))))
  274.         (PRADD2LNC (GETOP RENAME) '$RULES))
  275.       (WHEN (AND (SETQ VAL (CADR (GETL-FUN ITEM '(EXPR))))
  276.              (OR (MGET ITEM '$RULE) (GET ITEM 'TRANSLATED)))
  277.         #-Franz
  278.         (IF (MGET ITEM 'TRACE)
  279.             (LET (VAL1 #+PDP10 (OINT (NOINTERRUPT 'TTY)))
  280.               (REMPROP ITEM 'EXPR)
  281.               (IF (SETQ VAL1 (GET ITEM 'EXPR))
  282.               (DSKDEFPROP RENAME VAL1 'EXPR))
  283.               (SETPLIST ITEM (LIST* 'EXPR VAL (SYMBOL-PLIST ITEM)))
  284.               #+PDP10 (NOINTERRUPT OINT))
  285.             (DSKDEFPROP RENAME VAL 'EXPR))
  286.         #+Franz (fasprin `(def ,rename ,(getd item)))
  287.         (IF (SETQ VAL (ARGS ITEM))
  288.             (FASPRIN `(ARGS (QUOTE ,RENAME) (QUOTE ,VAL))))
  289.         (PROPSCHK ITEM RENAME 'TRANSLATED))
  290.       (WHEN (AND (SETQ VAL (GETL ITEM '(A-EXPR FEXPR TRANSLATED-MMACRO))) 
  291.              (GET ITEM 'TRANSLATED))
  292.         (DSKDEFPROP RENAME (CADR VAL) (CAR VAL))
  293.         (PROPSCHK ITEM RENAME 'TRANSLATED))
  294.       (WHEN (SETQ VAL (GET ITEM 'OPERATORS))
  295.         (DSKDEFPROP RENAME VAL 'OPERATORS)
  296.         (WHEN (SETQ VAL (GET ITEM 'RULES))
  297.               (DSKDEFPROP RENAME VAL 'RULES)
  298.               (SETQ X (CONS NIL (APPEND VAL (CDR X)))))
  299.         (IF (MEMQ ITEM (CDR $PROPS)) (PRADD2LNC RENAME '$PROPS))
  300.          (SETQ VAL (MGET ITEM 'OLDRULES))
  301.         (AND VAL (SETQ X (CONS NIL (NCONC (CDR (REVERSE VAL)) (CDR X))))))
  302.       (IF (MEMQ ITEM (CDR $FEATURES)) (PRADD2LNC RENAME '$FEATURES))
  303.       (WHEN (MEMQ (GETOP ITEM) (CDR $PROPS))
  304.         (DOLIST (IND INDLIST) (PROPSCHK ITEM RENAME IND))
  305.         (WHEN (GET (SETQ VAL (STRIPDOLLAR ITEM)) 'ALPHABET)
  306.                (DSKDEFPROP VAL T 'ALPHABET)
  307.               (PRADD2LNC (GETCHARN VAL 1) 'ALPHABET)
  308.               (PRADD2LNC ITEM '$PROPS))
  309.         (DOLIST (OPER OPERS) (PROPSCHK ITEM RENAME OPER)))
  310.       (WHEN (AND (SETQ VAL (GET ITEM 'OP)) (MEMQ VAL (CDR $PROPS)))
  311.         (DSKDEFPROP ITEM VAL 'OP)
  312.         (DSKDEFPROP VAL ITEM 'OPR)
  313.         (PRADD2LNC VAL '$PROPS)
  314.         (IF (SETQ VAL (EXTOPCHK ITEM VAL))
  315.             (SETQ X (LIST* NIL VAL (CDR X)))))
  316.       (WHEN (AND (SETQ VAL (GET ITEM 'GRAD)) (zl-ASSOC (NCONS ITEM) $GRADEFS))
  317.         (DSKDEFPROP RENAME VAL 'GRAD)
  318.         (PRADD2LNC (CONS (NCONS RENAME) (CAR VAL)) '$GRADEFS))
  319.       (WHEN (AND (GET ITEM 'DATA)
  320.              (NOT (MEMQ ITEM (CDR $CONTEXTS)))
  321.              (SETQ VAL (CDR ($FACTS ITEM))))
  322.         (FASPRIN `(RESTORE-FACTS (QUOTE ,VAL)))
  323.         (IF (MEMQ ITEM (CDR $PROPS)) (PRADD2LNC ITEM '$PROPS)))
  324.       (WHEN (AND (MEMQ ITEM (CDR $CONTEXTS))
  325.              (LET ((CONTEXT ITEM)) (SETQ VAL (CDR ($FACTS ITEM)))))
  326.         (FASPRINT T `(DSKSETQ $CONTEXT (QUOTE ,ITEM)))
  327.         (IF (MEMQ ITEM (CDR $ACTIVECONTEXTS))
  328.             (FASPRINT T `($ACTIVATE (QUOTE ,ITEM))))
  329.         (FASPRINT T `(RESTORE-FACTS (QUOTE ,VAL))))
  330.       (MPROPSCHK ITEM RENAME FILE STFL)
  331.       (IF (NOT (GET ITEM 'VERB))
  332.           (NCONC LIST (NCONS (OR NITEMFL (GETOP ITEM)))))))))
  333.  
  334. (DEFUN DSKATOM (ITEM RENAME VAL)
  335.  (COND ((EQ ITEM '$RATVARS)
  336.     (FASPRINT T `(SETQ VARLIST (APPEND VARLIST (QUOTE ,VARLIST))))
  337.     (FASPRINT T '(SETQ $RATVARS (CONS '(MLIST SIMP) VARLIST)))
  338.     (PRADD2LNC '$RATVARS '$MYOPTIONS))
  339.        ((MEMQ ITEM '($WEIGHTLEVELS $DONTFACTOR))
  340.     (FASPRIN `(SETQ ,ITEM (NCONC (QUOTE ,VAL) (CDR ,ITEM))))
  341.     (PRADD2LNC ITEM '$MYOPTIONS))
  342.        ((EQ ITEM 'TELLRATLIST)
  343.     (FASPRIN `(SETQ TELLRATLIST (NCONC (QUOTE ,VAL) TELLRATLIST)))
  344.     (PRADD2LNC 'TELLRATLIST '$MYOPTIONS))
  345.        ((EQ ITEM '*RATWEIGHTS)
  346.     (FASPRIN `(APPLY (FUNCTION $RATWEIGHT) (QUOTE ,(DOT2L VAL)))))
  347.        ((EQ ITEM '$FEATURES)
  348.     (DOLIST (VAR (CDR $FEATURES))
  349.         (IF (NOT (MEMQ VAR FEATUREL)) (PRADD2LNC VAR '$FEATURES))))
  350.        ((AND (EQ ITEM '$LINENUM) (EQ ITEM RENAME))
  351.     (FASPRINT T `(SETQ $LINENUM ,VAL)))
  352.        ((NOT ($RATP VAL))
  353.     (FASPRINT T (LIST 'DSKSETQ RENAME
  354.               (IF (OR (NUMBERP VAL) (MEMQ VAL '(NIL T)))
  355.                   VAL
  356.                   (LIST 'QUOTE VAL)))))
  357.        (T (FASPRINT T `(DSKSETQ ,RENAME (DSKRAT (QUOTE ,VAL)))))))
  358.  
  359. (DEFUN MPROPSCHK (ITEM RENAME FILE STFL)
  360.  (DO ((PROPS (CDR (OR (GET ITEM 'MPROPS) '(NIL))) (CDDR PROPS)) (VAL))
  361.      ((NULL PROPS))
  362.      (COND ((OR (MEMQ (CAR PROPS) '(TRACE TRACE-TYPE TRACE-LEVEL))
  363.         (MFILEP (SETQ VAL (CADR PROPS)))
  364.         (AND (EQ (CAR PROPS) 'T-MFEXPR) (NOT (GET ITEM 'TRANSLATED)))))
  365.        ((NOT (MEMQ (CAR PROPS) '(HASHAR ARRAY)))
  366.         (FASPRIN (LIST 'MDEFPROP RENAME VAL (CAR PROPS)))
  367.         (IF (NOT (MEMQ (CAR PROPS) '(MLEXPRP MFEXPRP T-MFEXPR)))
  368.         (INFOSTORE ITEM FILE (CAR PROPS) STFL
  369.                (COND ((MEMQ (CAR PROPS) '(MEXPR MMACRO))
  370.                   (LET ((VAL1 (ARGS ITEM)))
  371.                        (IF VAL1 (FASPRIN `(ARGS (QUOTE ,RENAME)
  372.                                 (QUOTE ,VAL1)))))
  373.                   (LET ((VAL1 (GET ITEM 'FUNCTION-MODE)))
  374.                        (IF VAL1 (DSKDEFPROP RENAME
  375.                                 VAL1
  376.                                 'FUNCTION-MODE)))
  377.                   (CONS (NCONS RENAME) (CDADR VAL)))
  378.                  ((EQ (CAR PROPS) 'DEPENDS)
  379.                   (CONS (NCONS RENAME) VAL))
  380.                  (T RENAME)))))
  381.        (T (DSKARY ITEM (LIST 'QUOTE RENAME) VAL (CAR PROPS))
  382.           (INFOSTORE ITEM FILE (CAR PROPS) STFL RENAME)))))
  383.  
  384. (DEFUN DSKARY (ITEM RENAME VAL IND)
  385.     ; Some small forms ordinarily non-EQ for fasdump must be output 
  386.     ; in proper sequence with the big mungeables.
  387.     ; For this reason only they are output as EQ-forms.
  388.  (LET ((ARY (COND ((AND (EQ IND 'array) (GET ITEM 'array)) RENAME)
  389.                 ; This code handles "COMPLETE" arrays.
  390.           (T (FASPRINT T '(SETQ AAAAA (GENSYM))) 'AAAAA)))
  391.        (DIMS (ARRAYDIMS VAL))
  392.        VAL1)
  393.       (IF (EQ IND 'HASHAR) (FASPRINT T `(REMCOMPARY ,RENAME)))
  394.       (FASPRINT T `(MREMPROP ,RENAME (QUOTE ,(IF (EQ IND 'array) 'HASHAR 'array))))
  395.       (FASPRINT T `(MPUTPROP ,RENAME ,ARY (QUOTE ,IND)))
  396.       (FASPRINT T `(*ARRAY ,ARY (QUOTE ,(CAR DIMS)) ,.(CDR DIMS)))
  397.       (FASPRINT T `(FILLARRAY ,ARY (QUOTE ,(LISTARRAY VAL))))
  398.       (IF (SETQ VAL1 (GET ITEM 'ARRAY-MODE))
  399.       (FASPRINT T `(DEFPROP ,(CADR RENAME) ,VAL1 ARRAY-MODE)))))
  400.  
  401. (DEFUN EXTOPCHK (ITEM VAL)
  402.  (LET ((VAL1 (IMPLODE (CONS #\$ (CDR (EXPLODEN VAL))))))
  403.    (WHEN (OR (GET VAL1 'NUD) (GET VAL1 'LED) (GET VAL1 'LBP))
  404.      (FASPRIN `(DEFINE-SYMBOL (QUOTE ,VAL)))
  405.      (IF (MEMQ VAL MOPL)
  406.          (FASPRIN `(SETQ MOPL (CONS (QUOTE ,VAL) MOPL))))
  407.      (WHEN (SETQ VAL (GET VAL1 'DIMENSION))
  408.            (DSKDEFPROP VAL1 VAL 'DIMENSION)
  409.            (DSKDEFPROP VAL1 (GET VAL1 'DISSYM) 'DISSYM)
  410.            (DSKDEFPROP VAL1 (GET VAL1 'GRIND) 'GRIND))
  411.      (IF (SETQ VAL (GET VAL1 'LBP)) (DSKDEFPROP VAL1 VAL 'LBP))
  412.      (IF (SETQ VAL (GET VAL1 'RBP)) (DSKDEFPROP VAL1 VAL 'RBP))
  413.      (IF (SETQ VAL (GET VAL1 'NUD)) (DSKDEFPROP VAL1 VAL 'NUD))
  414.      (IF (SETQ VAL (GET VAL1 'LED)) (DSKDEFPROP VAL1 VAL 'LED))
  415.      (WHEN (SETQ VAL (GET VAL1 'VERB))
  416.            (DSKDEFPROP VAL (GET VAL 'DIMENSION) 'DIMENSION)
  417.            (DSKDEFPROP VAL (GET VAL 'DISSYM) 'DISSYM))
  418.      (WHEN (SETQ VAL (GET ITEM 'MATCH))
  419.            (DSKDEFPROP ITEM VAL 'MATCH) VAL))))
  420.  
  421. (DEFUN PROPSCHK (ITEM RENAME IND)
  422.   (LET ((VAL (GET ITEM IND)))
  423.     (WHEN VAL (DSKDEFPROP RENAME VAL IND)
  424.           (PRADD2LNC (GETOP RENAME) '$PROPS))))
  425.  
  426. (DEFUN FASPRIN (FORM) (FASPRINT NIL FORM))
  427.  
  428. (DEFUN FASPRINT (EQFL FORM)
  429.   (COND ((NULL FASDUMPFL) #-Franz (PRINT FORM SAVEFILE)
  430.               #+Franz (pp-form form savefile))
  431.     (EQFL (SETQ FASDEQLIST (CONS FORM FASDEQLIST)))
  432.     (T (SETQ FASDNONEQLIST (CONS FORM FASDNONEQLIST)))))
  433.  
  434. (DEFUN UNSTOREP (ITEM) (I-$UNSTORE (NCONS ITEM)))
  435.  
  436. (DEFUN INFOSTORE (ITEM FILE FLAG STOREFL RENAME)
  437.  (LET ((PROP (COND ((EQ FLAG 'VALUE)
  438.             (IF (MEMQ RENAME (CDR $LABELS)) '$LABELS '$VALUES))
  439.            ((EQ FLAG 'MEXPR) '$FUNCTIONS)
  440.            ((EQ FLAG 'MMACRO) '$MACROS)
  441.            ((MEMQ FLAG '(ARRAY HASHAR)) '$ARRAYS)
  442.            ((EQ FLAG 'DEPENDS) (SETQ STOREFL NIL) '$DEPENDENCIES)
  443.            (T (SETQ STOREFL NIL) '$PROPS))))
  444.    (COND ((EQ PROP '$LABELS)
  445.       (FASPRIN `(ADDLABEL (QUOTE ,RENAME)))
  446.       (IF (GET ITEM 'NODISP) (DSKDEFPROP RENAME T 'NODISP)))
  447.      (T (PRADD2LNC RENAME PROP)))
  448.    (COND (STOREFL
  449.       (COND ((MEMQ FLAG '(MEXPR MMACRO)) (SETQ RENAME (CAAR RENAME)))
  450.         ((EQ FLAG 'array) (REMCOMPARY ITEM)))
  451.       (SETQ PROP (LIST '(MFILE) FILE RENAME))
  452.       (COND ((EQ FLAG 'VALUE) (SET ITEM PROP))
  453.         ((MEMQ FLAG '(MEXPR MMACRO AEXPR ARRAY HASHAR))
  454.          (MPUTPROP ITEM PROP FLAG)))))))
  455.  
  456. (DEFUN PRADD2LNC (ITEM PROP)
  457.   (IF (OR (NULL $PACKAGEFILE) (NOT (MEMQ PROP (CDR $INFOLISTS)))
  458.       (AND (EQ PROP '$PROPS) (GET ITEM 'OPR)))
  459.       (FASPRIN `(ADD2LNC (QUOTE ,ITEM) ,PROP))))
  460.  
  461. (DEFUN DSKDEFPROP (NAME VAL IND)
  462.   (FASPRIN (IF (AND (MEMQ IND '(EXPR FEXPR MACRO)) (EQ (CAR VAL) 'LAMBDA))
  463.            (LIST* 'DEFUN NAME
  464.               (IF (EQ IND 'EXPR) (CDR VAL) (CONS IND (CDR VAL))))
  465.            (LIST 'DEFPROP NAME VAL IND))))
  466.  
  467. (DEFUN DSKGET (FILE NAME FLAG UNSTOREP)
  468.  (LET ((DEFAULTF DEFAULTF) (EOF (LIST NIL)) ITEM #-cl(*NOPOINT T))
  469.    (SETQ FILE (OPEN FILE #-cl '(IN ASCII)))
  470.    (SETQ ITEM (DO ((ITEM (READ FILE EOF) (READ FILE EOF)))
  471.           ((EQ ITEM EOF) (MERROR "~%~:M not found" NAME))
  472.           (IF (OR (AND (NOT (ATOM ITEM)) (EQ (CAR ITEM) 'DSKSETQ)
  473.                    (EQ FLAG 'VALUE) (EQ (CADR ITEM) NAME))
  474.               (AND (NOT (ATOM ITEM)) (= (LENGTH ITEM) 4)
  475.                    (OR (EQ (CADDDR ITEM) FLAG)
  476.                    (AND (EQ (CAR (CADDDR ITEM)) 'QUOTE)
  477.                     (EQ (CADR (CADDDR ITEM)) FLAG)))
  478.                    (OR (EQ (CADR ITEM) NAME)
  479.                    (AND (EQ (CAADR ITEM) 'QUOTE)
  480.                     (EQ (CADADR ITEM) NAME)))))
  481.               (RETURN ITEM))))
  482.    (WHEN UNSTOREP (EVAL (READ FILE)) (EVAL (READ FILE)))
  483.    (CLOSE FILE)
  484.    (CADDR ITEM)))
  485.  
  486. (DEFUN DSKSAVE NIL
  487.   (LET ((DSKSAVEP T))
  488.     (IF $DSKALL (I-$STORE '($LABELS $VALUES $FUNCTIONS $MACROS $ARRAYS))
  489.         (I-$STORE '($LABELS)))))
  490.  
  491. ;(DEFMSPEC $REMFILE (L) (SETQ L (CDR L))
  492. ;  (IF (AND L (OR (CDR L) (NOT (MEMQ (CAR L) '($ALL $TRUE T)))))
  493. ;      (IMPROPER-ARG-ERR L '$REMFILE))
  494. ;  (DOLIST (FILE (IF L (APPEND FILELIST1 FILELIST) FILELIST))
  495. ;    (ERRSET (DELETEF FILE) NIL)
  496. ;    (SETQ FILELIST (zl-DELETE FILE FILELIST 1))
  497. ;    (SETQ FILELIST1 (zl-DELETE FILE FILELIST1 1)))
  498. ;  '$DONE)
  499.  
  500. (DEFMSPEC $RESTORE (FILE) (SETQ FILE (CDR FILE))
  501.  (LET ((EOF (NCONS NIL)) (IN (OPEN (FILESTRIP FILE)#-cl '(IN ASCII))))
  502.       (SETQ FILE (TRUENAME IN))
  503.       (SETQ FILE (IF (ATOM FILE) FILE (APPEND (CDR FILE) (CAR FILE))))
  504.       (DO ((ITEM (READ IN EOF) (READ IN EOF))) ((EQ ITEM EOF))
  505.       (COND ((AND (EQ (CAR ITEM) 'DSKSETQ) (NOT (OPTIONP (CADR ITEM))))
  506.          (SET (CADR ITEM) (LIST '(MFILE) FILE (CADR ITEM))))
  507.         ((AND (EQ (CAR ITEM) 'MDEFPROP)
  508.               (MEMQ (CADDDR ITEM) '(MEXPR MMACRO AEXPR)))
  509.          (MPUTPROP (CADR ITEM)
  510.                (LIST '(MFILE) FILE (CADR ITEM))
  511.                (CADDDR ITEM)))
  512.         ((AND (EQ (CAR ITEM) 'MPUTPROP)
  513.               (MEMQ (CADR (CADDDR ITEM)) '(ARRAY HASHAR)))
  514.          (MPUTPROP (CADADR ITEM)
  515.                (LIST '(MFILE) FILE (CADADR ITEM))
  516.                (CADR (CADDDR ITEM)))
  517.          (DO ((ITEM (READ IN) (READ IN))) (NIL)
  518.              (IF (EQ (CAR ITEM) 'ADD2LNC) (RETURN (EVAL ITEM)))))
  519.         (T (EVAL ITEM))))
  520.       (CLOSE IN)
  521.       (IF $CHANGE_FILEDEFAULTS (DEFAULTF FILE))
  522.       (IF (ATOM FILE) FILE (MFILE-OUT FILE))))
  523.  
  524.